home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
UNITS
/
MISCPARS.INC
< prev
next >
Wrap
Text File
|
1994-02-17
|
12KB
|
463 lines
const Numerics = [ '0'..'9','.','+','-' ];
const Alphas = [ 'A'..'Z','a'..'z' ];
const AlphaNumerics = Alphas + Numerics;
{SECTION CleanUpBlanks }
Procedure CleanUpBlanks(var s : string);
var done : boolean;
stringhold : string;
begin
Trim(s);
TokenizeStrings(s,stringhold);
RemoveExcessBlanks(s);
if stringhold > '' then DeTokenizeStrings(s,stringhold);
end;
{SECTION CleanUpComments }
Procedure CleanUpComments(var s : string);
{ get rid of excess blanks to prepare for parsing }
var done : boolean;
begin
RemoveEOLComments(s,commenteolchar);
done := false;
while not done do
done := RemoveBracketComments(s,commentpairLchar,commentpairRchar);
end;
{SECTION CleanUpString }
Procedure CleanUpString(var s : string);
{ clean out comments and excess blanks to prepare for parsing }
begin
CleanUpComments(s);
CleanUpBlanks(s);
end;
{SECTION DeQuoteString }
Function DeQuoteString(s : string) : string;
var s1 : string;
begin
s1 := s;
if s1[1] = quotechar then delete(s1,1,1);
if s1[length(s1)] = quotechar then delete(s1,length(s1),1);
DeQuoteString := s1;
end;
{SECTION DeTokenizeStrings }
Procedure DeTokenizeStrings(var s,hold : string);
var i,j : integer;
dummy : boolean;
s2 : string;
begin
i := 1;
while i > 0 do
begin
i := pos(qstringtoken,s);
if i > 0 then
begin
s2 := '';
{ s[i] := '#'; }
delete(s,i,1);
dummy := ReplaceStringWithToken(hold,s2,qstringtoken);
insert(s2,s,i);
s2 := '';
end;
end;
end;
{SECTION GETAlphaNumericStr }
Function GETAlphaNumericStr ( var s : string) : string;
var s1 : string;
i : integer;
begin
s1 := '';
while (length(s) > 0) and not (s[1] in AlphaNumerics) do delete(s,1,1);
while (length(s) > 0) and (s[1] in AlphaNumerics) do
begin
s1 := s1 + s[1];
delete(s,1,1);
end;
GETAlphaNumericStr := s1;
end;
{SECTION GETAlphaStr }
Function GETAlphaStr ( var s : string) : string;
var s1 : string;
i : integer;
begin
s1 := '';
while (length(s) > 0) and not (s[1] in Alphas) do delete(s,1,1);
while (length(s) > 0) and (s[1] in Alphas ) do
begin
s1 := s1 + s[1];
delete(s,1,1);
end;
GETAlphaStr := s1;
end;
{SECTION GETBoolean }
Function GETBoolean (var s : string) : boolean;
var x : boolean;
s1 : string;
code : integer;
begin
x := true;
s1 := UpCaseStr(GetAlphaStr(s));
if (s1 = 'NO') or (s1 = 'OFF') then x := false;
GETBoolean := x;
end;
{SECTION GetDelimitedStr }
Function GETDelimitedStr ( var s : string; lchr,rchr : char) : string;
{[STRING] Removes string in paired brackets, l & r CAN be same}
var s1 : string;
i,j,l : integer;
begin
s1 := '';
i := lscan(s,lchr);
if (i > 0) then
begin
j := rscan(s,rchr);
if j > i then
begin
l := (j - i) - 1;
if (j > i) then
begin
if (l > 0) then s1 := copy(s,i+1,l);
delete(s,i,(j-i+1));
end;
end;
end;
GETDelimitedStr := trimstr(s1);
end;
{SECTION GETInteger }
Function GETInteger (var s : string) : integer;
var x : integer;
s1 : string;
code : integer;
begin
x := 0;
s1 := GetNumericStr(s);
val(s1,x,code);
GETInteger := x;
end;
{SECTION GetLeftStr }
Function GetLeftStr ( var s : string; tch : char) : string;
{ Note, if char not there, returns WHOLE string }
var s1 : string;
i,l : integer;
begin
trim(s);
i := pos(tch,s);
if i > 0 then
begin
s1 := copy(s,1,i-1);
delete(s,1,i);
end
else begin
s1 := s;
s := '';
end;
GetLeftStr := trimstr(s1);
end;
{SECTION GETLongInt }
Function GETLongInt (var s : string) : longint;
var x : longint;
s1 : string;
code : integer;
begin
x := 0;
s1 := GetNumericStr(s);
val(s1,x,code);
GETLongInt := x;
end;
{SECTION GETNumericStr }
Function GETNumericStr ( var s : string) : string;
var s1 : string;
i : integer;
begin
s1 := '';
while (length(s) > 0) and not (s[1] in Numerics) do delete(s,1,1);
while (length(s) > 0) and (s[1] in Numerics) do
begin
s1 := s1 + s[1];
delete(s,1,1);
end;
GETNumericStr := s1;
end;
{SECTION GETReal }
Function GETReal (var s : string) : real;
var x : real;
s1 : string;
code : integer;
begin
x := 0;
s1 := GetNumericStr(s);
val(s1,x,code);
GETReal := x;
end;
{SECTION GetRightStr }
Function GetRightStr ( var s : string; tch : char) : string;
{ Note, if char not there, returns EMPTY string }
var s1 : string;
i,l : integer;
begin
s1 := trimstr(s);
i := rscan(s1,tch);
if i > 0 then
begin
s := copy(s1,1,i-1);
delete(s1,1,i);
end
else begin
s1 := '';
end;
GetRightStr := trimstr(s1);
end;
{SECTION LScan }
Function LScan(str : string; tch : char) : byte;
{[STRING] finds FIRST occurance of char TCH in string STR }
var i,j : integer;
begin
j := 0;
i := 0;
while (i < length(str)) and (j = 0) do
begin
inc(i);
if str[i] = tch then j := i;
end;
LScan := j;
end;
{SECTION NibbleString }
Function NibbleString(var s : string;tch : termchars; var termch : char) : string;
{[STRING] fetches to one of a SET of chars - see also GetLeftStr }
var dummy, done : boolean;
i : integer;
stringhold,s1 : string;
begin
termch := '%';
s1 := '';
RemoveLeading(s,' ');
TokenizeStrings(s,stringhold);
if s[1] = qstringtoken then
begin
dummy := ReplaceStringWithToken(stringhold,s1,qstringtoken);
delete(s,1,1);
delete(stringhold,1,1);
termch := ' ';
end
else begin
done := false;
i := 1;
while (i <= length(s)) and not done do
begin
if (s[i] in tch) then
begin
s1 := copy(s,1,i-1);
termch := s[i];
delete(s,1,i);
done := true;
end
else inc(i);
end;
if not done then
begin
s1 := s;
s := '';
end;
end;
if stringhold > '' then
DeTokenizeStrings(s,stringhold);
NibbleString := s1;
end;
{SECTION RemoveBracketComments }
Function RemoveBracketComments(var s : string; lchar,rchar : char) : boolean;
{ get rid of comments to prepare for parsing }
var i,j,k : integer;
done : boolean;
begin
done := true;
if lchar <> chr(0) then
begin
if multilinecomment then
begin {looking for close}
j := pos(rchar,s);
if j > 0 then
begin
delete(s,1,j);
multilinecomment := false;
done := false;
end
else s := ''; {still in multiline comment}
end
else begin {looking for open comment }
i := pos(lchar,s);
if i > 0 then
begin
done := false;
j := pos(rchar,s);
if j > i then
begin
delete(s,i,(j-i)+1);
end
else begin
s := leftstr(s,i-1);
multilinecomment := true;
end;
end;
end;
end;
RemoveBracketComments := done;
end;
{SECTION RemoveDelimitedString }
Procedure RemoveDelimitedString ( var s : string; lchr,rchr : char);
var s1 : string[1];
begin
s1 := GetDelimitedStr(s,lchr,rchr);
end;
{SECTION RemoveEOLComments }
Procedure RemoveEOLComments(var s : string; cchar : char);
{ get rid of comments to prepare for parsing }
var i : integer;
begin
if cchar <> chr(0) then
begin
i := pos(cchar,s);
if i > 0 then
begin
s := leftstr(s,i-1);
end;
end;
end;
{SECTION ReplaceStringWithToken }
Function ReplaceStringWithToken(var s,s1 : string; token : char) : boolean;
var notdone : boolean;
i,j : integer;
begin
notdone := false;
s1 := '';
i := pos(quotechar,s);
if i > 0 then
begin
s[i] := token;
j := pos(quotechar,s);
if j > i then
begin
s1 := quotechar + copy(s,i+1,(j-i));
delete(s,i+1,(j-i));
notdone := true;
end
else s[i] := quotechar; { mismatched quotes, put it back }
if s[i] = chr(0) then delete(s,i,1);
end;
ReplaceStringWithToken := notdone;
end;
{SECTION Rpos }
Function Rpos(substr,str : string) : byte;
{[STRING] equivalent to pos, but returns last occurance }
var i,j : integer;
s : string;
begin
j := 0; i := 0;
s := str;
i := pos(substr,s);
while i > 0 do
begin
j := i; { j will have the position of the last match }
s[i] := '~'; { so doesn't match again }
i := pos(substr,s);
end;
Rpos := j;
end;
{SECTION RScan }
Function RScan(str : string; tch : char) : byte;
{[STRING] finds LAST occurance of char TCH in string STR }
var i,j : integer;
begin
j := 0;
for i := 1 to length(str) do if str[i] = tch then j := i;
RScan := j;
end;
{SECTION ScanStufInit }
Procedure ScanStufInit;
begin
quotechar := chr(34); { double quote char }
commenteolchar := chr(33); { exclamation point }
commentpairLchar := chr(123); { left squiggley bracket }
commentpairRchar := chr(125); { right squiggley bracket }
qstringtoken := chr(255); { something unnatural in a string }
multilinecomment := false; {true while mismatched comment brackets}
end;
{SECTION ShiftUPString }
Procedure ShiftUPString(var s : string);
var done : boolean;
stringhold : string;
begin
TokenizeStrings(s,stringhold);
s := UpCaseStr(s);
if stringhold > '' then DeTokenizeStrings(s,stringhold);
end;
{SECTION TokenizeStrings }
Procedure TokenizeStrings(var s,hold : string);
var i,j : integer;
s1 : string;
begin
hold := '';
while ReplaceStringWithToken(s,s1,qstringtoken) do hold := hold + s1;
end;